PCGUIA 127/PC Guia 127.iso/Software/Produtividade/OpenOffice.org 2.0.1/openofficeorg1.cab/Misc.xba

Extensible Markup Language | 2005-01-31 | 26KB | 817 lines

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Misc" script:language="StarBasic">REM  *****  BASIC  *****

Const SBSHARE = 0
Const SBUSER = 1
Dim Taskindex as Integer
Dim oResSrv as Object

Sub Main()
Dim PropList(3,1)' as String
    PropList(0,0) = "URL"
    PropList(0,1) = "sdbc:odbc:Erica_Test_Unicode"
    PropList(1,0) = "User"
    PropList(1,1) = "extra"
    PropList(2,0) = "Password"
    PropList(2,1) = "extra"
    PropList(3,0) = "IsPasswordRequired"
    PropList(3,1) = True
End Sub


Function RegisterNewDataSource(DSName as  String, PropertyList(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue)
Dim oDataSource as Object
Dim oDBContext as Object
Dim oPropInfo as Object
Dim i as Integer
    oDBContext = createUnoService("com.sun.star.sdb.DatabaseContext")
    oDataSource = createUnoService("com.sun.star.sdb.DataSource")
    For i = 0 To Ubound(PropertyList(), 1)
        sPropName = PropertyList(i,0)
        sPropValue = PropertyList(i,1)
        oDataSource.SetPropertyValue(sPropName,sPropValue)
    Next i
    If Not IsMissing(DriverProperties()) Then
        oDataSource.Info() = DriverProperties()
    End If
    oDBContext.RegisterObject(DSName, oDataSource)
    RegisterNewDataSource () = oDataSource
End Function


' Connects to a registered Database
Function ConnecttoDatabase(DSName as String, UserID as String, Password as String, Optional Propertylist(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue)
Dim oDBContext as Object
Dim oDBSource as Object
'    On Local Error Goto NOCONNECTION
    oDBContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
    If oDBContext.HasbyName(DSName) Then
        oDBSource = oDBContext.GetByName(DSName)
        ConnectToDatabase = oDBSource.GetConnection(UserID, Password)
    Else
        If Not IsMissing(Namelist()) Then
            If Not IsMissing(DriverProperties()) Then
                RegisterNewDataSource(DSName, PropertyList(), DriverProperties())
            Else
                RegisterNewDataSource(DSName, PropertyList())
            End If
            oDBSource = oDBContext.GetByName(DSName)
            ConnectToDatabase = oDBSource.GetConnection(UserID, Password)
        Else
            Msgbox("DataSource " & DSName & " is not registered" , 16, GetProductname())
            ConnectToDatabase() = NULL
        End If
    End If
NOCONNECTION:
    If Err <> 0 Then
        Msgbox(Error$, 16, GetProductName())
        Resume LEAVESUB
        LEAVESUB:
    End If
End Function


Function GetStarOfficeLocale() as New com.sun.star.lang.Locale
Dim aLocLocale As New com.sun.star.lang.Locale
Dim sLocale as String
Dim sLocaleList(1)
Dim oMasterKey
    oMasterKey = GetRegistryKeyContent("org.openoffice.Setup/L10N/")
    sLocale = oMasterKey.getByName("ooLocale")
    sLocaleList() = ArrayoutofString(sLocale, "-")
    aLocLocale.Language = sLocaleList(0)
    If Ubound(sLocaleList()) > 0 Then
        aLocLocale.Country = sLocaleList(1)
    End If
    GetStarOfficeLocale() = aLocLocale
End Function


Function GetRegistryKeyContent(sKeyName as string, Optional bforUpdate as Boolean)
Dim oConfigProvider as Object
Dim aNodePath(0) as new com.sun.star.beans.PropertyValue
    oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider")
    aNodePath(0).Name = "nodepath"
    aNodePath(0).Value = sKeyName
    If IsMissing(bForUpdate) Then
        GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", aNodePath())
    Else
        If bForUpdate Then
            GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationUpdateAccess", aNodePath())
        Else
            GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", aNodePath())
        End If
    End If
End Function


Function GetProductname() as String
Dim oProdNameAccess as Object
Dim sVersion as String
Dim sProdName as String
    oProdNameAccess = GetRegistryKeyContent("org.openoffice.Setup/Product")
    sProdName = oProdNameAccess.getByName("ooName")
    sVersion = oProdNameAccess.getByName("ooSetupVersion")
    GetProductName = sProdName & sVersion
End Function


' Opens a Document, checks beforehand, wether it has to be loaded
' or wether it is already on the desktop.
' If the parameter bDisposable is set to False then then returned document
' should not be disposed afterwards, because it is already opened.
Function OpenDocument(DocPath as String, Args(), Optional bDisposable as Boolean)
Dim oComponents as Object
Dim oComponent as Object
    ' Search if one of the active Components ist the one that you search for
    oComponents = StarDesktop.Components.CreateEnumeration
    While oComponents.HasmoreElements
        oComponent = oComponents.NextElement
        If hasUnoInterfaces(oComponent,"com.sun.star.frame.XModel") then
            If UCase(oComponent.URL) = UCase(DocPath) then
                OpenDocument() = oComponent
                If Not IsMissing(bDisposable) Then
                    bDisposable = False
                End If
                Exit Function
            End If
        End If
    Wend
    If Not IsMissing(bDisposable) Then
        bDisposable = True
    End If
    OpenDocument() = StarDesktop.LoadComponentFromURL(DocPath,"_default",0,Args())
End Function


Function TaskonDesktop(DocPath as String) as Boolean
Dim oComponents as Object
Dim oComponent as Object
    ' Search if one of the active Components ist the one that you search for
    oComponents = StarDesktop.Components.CreateEnumeration
    While oComponents.HasmoreElements
        oComponent = oComponents.NextElement
            If hasUnoInterfaces(oComponent,"com.sun.star.frame.XModel") then
            If UCase(oComponent.URL) = UCase(DocPath) then
                TaskonDesktop = True
                Exit Function
            End If
        End If
    Wend
    TaskonDesktop = False
End Function


' Retrieves a FileName out of a StarOffice-Document
Function RetrieveFileName(LocDoc as Object)
Dim LocURL as String
Dim LocURLArray() as String
Dim MaxArrIndex as integer

    LocURL = LocDoc.Url
    LocURLArray() = ArrayoutofString(LocURL,"/",MaxArrIndex)
    RetrieveFileName = LocURLArray(MaxArrIndex)
End Function


' Gets a special configured PathSetting
Function GetPathSettings(sPathType as String,  Optional bshowall as Boolean, Optional ListIndex as integer) as String
Dim oSettings, oPathSettings as Object
Dim sPath as String
Dim PathList() as String
Dim MaxIndex as Integer
Dim oPS as Object

    oPS = createUnoService("com.sun.star.util.PathSettings")

      If Not IsMissing(bShowall) Then
        If bShowAll Then
            ShowPropertyValues(oPS)
            Exit Function
        End If
    End If
     sPath = oPS.getPropertyValue(sPathType)
    If Not IsMissing(ListIndex) Then
        ' Share and User-Directory
        If Instr(1,sPath,";") <> 0 Then
            PathList = ArrayoutofString(sPath,";", MaxIndex)
            If ListIndex <= MaxIndex Then
                sPath = PathList(ListIndex)
            Else
                Msgbox("String Cannot be analyzed!" & sPath , 16, GetProductName())
            End If
        End If
    End If
    If Instr(1, sPath, ";") = 0 Then
        GetPathSettings = ConvertToUrl(sPath)
    Else
        GetPathSettings = sPath
    End If

End Function



' Gets the fully qualified path to a subdirectory of the
' Template Directory, e. g. with the parameter "wizard/bitmap"
' The parameter must be passed over in Url-scription
' The return-Value is in Urlscription
Function GetOfficeSubPath(sOfficePath as String, ByVal sSubDir as String)
Dim sOfficeString as String
Dim sOfficeList() as String
Dim sOfficeDir as String
Dim sBigDir as String
Dim i as Integer
Dim MaxIndex as Integer
Dim oUcb as Object
    oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess")
    sOfficeString = GetPathSettings(sOfficePath)
    If Right(sSubDir,1) <> "/" Then
        sSubDir = sSubDir & "/"
    End If
    sOfficeList() = ArrayoutofString(sOfficeString,";", MaxIndex)
    For i = 0 To MaxIndex
        sOfficeDir = ConvertToUrl(sOfficeList(i))
        If Right(sOfficeDir,1) <> "/" Then
            sOfficeDir = sOfficeDir & "/"
        End If
        sBigDir = sOfficeDir & sSubDir
        If oUcb.Exists(sBigDir) Then
            GetOfficeSubPath() = sBigDir
            Exit Function
        End If
    Next i
    ShowNoOfficePathError()
    GetOfficeSubPath = ""
End Function


Sub ShowNoOfficePathError()
Dim ProductName as String
Dim sError as String
Dim bResObjectexists as Boolean
Dim oLocResSrv as Object
    bResObjectexists = not IsNull(oResSrv)
    If bResObjectexists Then
        oLocResSrv = oResSrv
    End If
    If InitResources("Tools", "com") Then
        ProductName = GetProductName()
        sError = GetResText(1006)
        sError = ReplaceString(sError, ProductName, "%PRODUCTNAME")
        sError = ReplaceString(sError, chr(13), "<BR>")
        MsgBox(sError, 16, ProductName)
    End If
    If bResObjectexists Then
        oResSrv = oLocResSrv
    End If

End Sub


Function InitResources(Description, ShortDescription as String) as boolean
    On Error Goto ErrorOcurred
    oResSrv = createUnoService( "com.sun.star.resource.VclStringResourceLoader" )
    If (IsNull(oResSrv)) then
        InitResources = FALSE
        MsgBox( Description & ": No resource loader found", 16, GetProductName())
    Else
        InitResources = TRUE
        oResSrv.FileName = ShortDescription
    End If
    Exit Function
ErrorOcurred:
    Dim nSolarVer
    InitResources = FALSE
    nSolarVer = GetSolarVersion()
    MsgBox("Resource file missing (" & ShortDescription  & trim(str(nSolarVer)) + "*.res)", 16, GetProductName())
    Resume CLERROR
    CLERROR:
End Function


Function GetResText( nID as integer ) As string
    On Error Goto ErrorOcurred
    If Not IsNull(oResSrv) Then
        GetResText = oResSrv.getString( nID )
    Else
        GetResText = ""
    End If
    Exit Function
ErrorOcurred:
    GetResText = ""
    MsgBox("Resource with ID =" + str( nID ) + " not found!", 16, GetProductName())
    Resume CLERROR
    CLERROR:
End Function


Function CutPathView(sDocUrl as String, Optional PathLen as Integer)
Dim sViewPath as String
Dim FileName as String
Dim iFileLen as Integer
    sViewPath = ConvertfromURL(sDocURL)
    iViewPathLen = Len(sViewPath)
    If iViewPathLen > 60 Then
        FileName = FileNameoutofPath(sViewPath, "/")
        iFileLen = Len(FileName)
        If iFileLen < 44 Then
            sViewPath = Left(sViewPath,57-iFileLen-10) & "..." & Right(sViewPath,iFileLen + 10)
        Else
            sViewPath = Left(sViewPath,27) & " ... " & Right(sViewPath,28)
        End If
    End If
    CutPathView = sViewPath
End Function


' Deletes the content of all cells that are softformatted according
' to the 'InputStyleName'
Sub DeleteInputCells(oSheet as Object, InputStyleName as String)
Dim oRanges as Object
Dim oRange as Object
    oRanges = oSheet.CellFormatRanges.createEnumeration
    While oRanges.hasMoreElements
        oRange = oRanges.NextElement
        If Instr(1,oRange.CellStyle, InputStyleName) <> 0 Then
            Call ReplaceRangeValues(oRange, "")
        End If
    Wend
End Sub


' Inserts a certain String to all cells of a Range that ist passed over
' either as an object or as the RangeName
Sub ChangeValueofRange(oSheet as Object, Range, ReplaceValue, Optional StyleName as String)
Dim oCellRange as Object
    If Vartype(Range) = 8 Then
        ' Get the Range out of the Rangename
        oCellRange = oSheet.GetCellRangeByName(Range)
    Else
        ' The range is passed over as an object
        Set oCellRange = Range
    End If
    If IsMissing(StyleName) Then
        ReplaceRangeValues(oCellRange, ReplaceValue)
    Else
        If Instr(1,oCellRange.CellStyle,StyleName) Then
            ReplaceRangeValues(oCellRange, ReplaceValue)
        End If
    End If
End Sub


Sub ReplaceRangeValues(oRange as Object, ReplaceValue)
Dim oRangeAddress as Object
Dim ColCount as Integer
Dim RowCount as Integer
Dim i as Integer
    oRangeAddress = oRange.RangeAddress
    ColCount = oRangeAddress.EndColumn - oRangeAddress.StartColumn
    RowCount = oRangeAddress.EndRow - oRangeAddress.StartRow
    Dim FillArray(RowCount) as Variant
    Dim sLine(ColCount) as Variant
    For i = 0 To ColCount
        sLine(i) = ReplaceValue
    Next i
    For i = 0 To RowCount
        FillArray(i) = sLine()
    Next i
    oRange.DataArray = FillArray()
End Sub


' Returns the Value of the first cell of a Range
Function GetValueofCellbyName(oSheet as Object, sCellName as String)
Dim oCell as Object
    oCell = GetCellByName(oSheet, sCellName)
    GetValueofCellbyName = oCell.Value
End Function


Function DuplicateRow(oSheet as Object, RangeName as String)
Dim oRange as Object
Dim oCell as Object
Dim oCellAddress as New com.sun.star.table.CellAddress
Dim oRangeAddress as New com.sun.star.table.CellRangeAddress
    oRange = oSheet.GetCellRangeByName(RangeName)
    oRangeAddress = oRange.RangeAddress
    oCell = oSheet.GetCellByPosition(oRangeAddress.StartColumn,oRangeAddress.StartRow)
    oCellAddress = oCell.CellAddress
    oSheet.Rows.InsertByIndex(oCellAddress.Row,1)
    oRangeAddress = oRange.RangeAddress
    oSheet.CopyRange(oCellAddress, oRangeAddress)
    DuplicateRow = oRangeAddress.StartRow-1
End Function


' Returns the String of the first cell of a Range
Function GetStringofCellbyName(oSheet as Object, sCellName as String)
Dim oCell as Object
    oCell = GetCellByName(oSheet, sCellName)
    GetStringofCellbyName = oCell.String
End Function


' Returns a named Cell
Function GetCellByName(oSheet as Object, sCellName as String) as Object
Dim oCellRange as Object
Dim oCellAddress as Object
    oCellRange = oSheet.GetCellRangeByName(sCellName)
    oCellAddress = oCellRange.RangeAddress
    GetCellByName = oSheet.GetCellByPosition(oCellAddress.StartColumn,oCellAddress.StartRow)
End Function


' Changes the numeric Value of a cell by transmitting the String of the numeric Value
Sub ChangeCellValue(oCell as Object, ValueString as String)
Dim CellValue
    oCell.Formula = "=Value(" & """" & ValueString & """" & ")"
    CellValue = oCell.Value
    oCell.Formula = ""
    oCell.Value = CellValue
End Sub


Function GetDocumentType(oDocument)
    On Local Error GoTo NODOCUMENTTYPE
'    ShowSupportedServiceNames(oDocument)
    If oDocument.SupportsService("com.sun.star.sheet.SpreadsheetDocument") Then
        GetDocumentType() = "scalc"
    ElseIf oDocument.SupportsService("com.sun.star.text.TextDocument") Then
        GetDocumentType() = "swriter"
    ElseIf oDocument.SupportsService("com.sun.star.drawing.DrawingDocument") Then
        GetDocumentType() = "sdraw"
    ElseIf oDocument.SupportsService("com.sun.star.presentation.PresentationDocument") Then
        GetDocumentType() = "simpress"
    ElseIf oDocument.SupportsService("com.sun.star.formula.FormulaProperties") Then
        GetDocumentType() = "smath"
    End If
    NODOCUMENTTYPE:
    If Err <> 0 Then
        GetDocumentType = ""
        Resume GOON
        GOON:
    End If
End Function


Function GetNumberFormatType(oDocFormats, oFormatObject as Object) as Integer
Dim ThisFormatKey as Long
Dim oObjectFormat as Object
    On Local Error Goto NOFORMAT
    ThisFormatKey = oFormatObject.NumberFormat
    oObjectFormat = oDocFormats.GetByKey(ThisFormatKey)
    GetNumberFormatType = oObjectFormat.Type
    NOFORMAT:
    If Err <> 0 Then
        Msgbox("Numberformat of Object is not available!", 16, GetProductName())
        GetNumberFormatType = 0
        GOTO NOERROR
    End If
    NOERROR:
    On Local Error Goto 0
End Function


Sub ProtectSheets(Optional oSheets as Object)
Dim i as Integer
Dim oDocSheets as Object
    If IsMissing(oSheets) Then
        oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets
    Else
        Set oDocSheets = oSheets
    End If

    For i = 0 To oDocSheets.Count-1
        oDocSheets(i).Protect("")
    Next i
End Sub


Sub UnprotectSheets(Optional oSheets as Object)
Dim i as Integer
Dim oDocSheets as Object
    If IsMissing(oSheets) Then
        oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets
    Else
        Set oDocSheets = oSheets
    End If

    For i = 0 To oDocSheets.Count-1
        oDocSheets(i).Unprotect("")
    Next i
End Sub


Function GetRowIndex(oSheet as Object, RowName as String)
Dim oRange as Object
    oRange = oSheet.GetCellRangeByName(RowName)
    GetRowIndex = oRange.RangeAddress.StartRow
End Function


Function GetColumnIndex(oSheet as Object, ColName as String)
Dim oRange as Object
    oRange = oSheet.GetCellRangeByName(ColName)
    GetColumnIndex = oRange.RangeAddress.StartColumn
End Function


Function CopySheetbyName(oSheets as Object, OldName as String, NewName as String, DestPos as Integer) as Object
Dim oSheet as Object
Dim Count as Integer
Dim BasicSheetName as String

    BasicSheetName = NewName
    ' Copy the last table. Assumption: The last table is the template
    On Local Error Goto RENAMESHEET
    oSheets.CopybyName(OldName, NewName, DestPos)

RENAMESHEET:
    oSheet = oSheets(DestPos)
    If Err <> 0 Then
        ' Test if renaming failed
        Count = 2
        Do While oSheet.Name <> NewName
            NewName = BasicSheetName & "_" & Count
            oSheet.Name = NewName
            Count = Count + 1
        Loop
        Resume CL_ERROR
CL_ERROR:
    End If
    CopySheetbyName = oSheet
End Function


' Dis-or enables a Window and adjusts the mousepointer accordingly
Sub ToggleWindow(bDoEnable as Boolean)
Dim oWindow as Object
    oWindow = StarDesktop.CurrentFrame.ComponentWindow
    oWindow.Enable = bDoEnable
End Sub


Function CheckNewSheetname(oSheets as Object, Sheetname as String, Optional oLocale) as String
Dim nStartFlags as Long
Dim nContFlags as Long
Dim oCharService as Object
Dim iSheetNameLength as Integer
Dim iResultPos as Integer
Dim WrongChar as String
Dim oResult as Object
    nStartFlags = com.sun.star.i18n.KParseTokens.ANY_LETTER_OR_NUMBER + com.sun.star.i18n.KParseTokens.ASC_UNDERSCORE
    nContFlags = nStartFlags
    oCharService = CreateUnoService("com.sun.star.i18n.CharacterClassification")
    iSheetNameLength = Len(SheetName)
    If IsMissing(oLocale) Then
        oLocale = ThisComponent.CharLocale
    End If
    Do
        oResult =oCharService.parsePredefinedToken(com.sun.star.i18n.KParseType.IDENTNAME, SheetName, 0, oLocale, nStartFlags, "", nContFlags, " ")
        iResultPos = oResult.EndPos
        If iResultPos < iSheetNameLength Then
            WrongChar = Mid(SheetName, iResultPos+1,1)
            SheetName = ReplaceString(SheetName,"_", WrongChar)
        End If
    Loop Until iResultPos = iSheetNameLength
    CheckNewSheetname = SheetName
End Function


Sub AddNewSheetName(oSheets as Object, ByVal SheetName as String)
Dim Count as Integer
Dim bSheetIsThere as Boolean
Dim iSheetNameLength as Integer
    iSheetNameLength = Len(SheetName)
    Count = 2
    Do
        bSheetIsThere = oSheets.HasByName(SheetName)
        If bSheetIsThere Then
            SheetName = Right(SheetName,iSheetNameLength) & "_" & Count
            Count = Count + 1
        End If
    Loop Until Not bSheetIsThere
    AddNewSheetname = SheetName
End Sub


Function GetSheetIndex(oSheets, sName) as Integer
Dim i as Integer
    For i = 0 To oSheets.Count-1
        If oSheets(i).Name = sName Then
            GetSheetIndex = i
            exit Function
        End If
    Next i
    GetSheetIndex = -1
End Function


Function GetLastUsedRow(oSheet as Object) as Integer
Dim oCell As Object
Dim oCursor As Object
Dim aAddress As Variant
    oCell = oSheet.GetCellbyPosition(0, 0)
    oCursor = oSheet.createCursorByRange(oCell)
    oCursor.GotoEndOfUsedArea(True)
    aAddress = oCursor.RangeAddress
    GetLastUsedRow = aAddress.EndRow
End Function


' Note To set a one lined frame you have to set the inner width to 0
' In the API all Units that refer to pt-Heights are "1/100mm"
' The convert factor from 1pt to 1/100 mm is approximately 35
Function ModifyBorderLineWidth(ByVal oStyleBorder, iInnerLineWidth as Integer, iOuterLineWidth as Integer)
Dim aBorder as New com.sun.star.table.BorderLine
    aBorder = oStyleBorder
    aBorder.InnerLineWidth = iInnerLineWidth
    aBorder.OuterLineWidth = iOuterLineWidth
    ModifyBorderLineWidth = aBorder
End Function


Sub AttachBasicMacroToEvent(oDocument as Object, EventName as String, SubPath as String)
Dim PropValue(1) as new com.sun.star.beans.PropertyValue
    PropValue(0).Name = "EventType"
    PropValue(0).Value = "StarBasic"
    PropValue(1).Name = "Script"
    PropValue(1).Value = "macro:///" & SubPath
    oDocument.Events.ReplaceByName(EventName, PropValue())
End Sub



Function ModifyPropertyValue(oContent() as New com.sun.star.beans.PropertyValue, TargetProperties() as New com.sun.star.beans.PropertyValue)
Dim MaxIndex as Integer
Dim i as Integer
Dim a as Integer
    MaxIndex = Ubound(oContent())
    bDoReplace = False
    For i = 0 To MaxIndex
        a = GetPropertyValueIndex(oContent(i).Name, TargetProperties())
        If a <> -1 Then
            If Vartype(TargetProperties(a).Value) <> 9 Then
                If TargetProperties(a).Value <> oContent(i).Value Then
                    oContent(i).Value = TargetProperties(a).Value
                    bDoReplace = True
                End If
            Else
                If Not EqualUnoObjects(TargetProperties(a).Value, oContent(i).Value) Then
                    oContent(i).Value = TargetProperties(a).Value
                    bDoReplace = True
                End If
            End If
        End If
    Next i
    ModifyPropertyValue() = bDoReplace
End Function


Function GetPropertyValueIndex(SearchName as String, TargetProperties() as New com.sun.star.beans.PropertyValue ) as Integer
Dim i as Integer
    For i = 0 To Ubound(TargetProperties())
        If Searchname = TargetProperties(i).Name Then
            GetPropertyValueIndex = i
            Exit Function
        End If
    Next i
    GetPropertyValueIndex() = -1
End Function


Sub DispatchSlot(SlotID as Integer)
Dim oArg() as new com.sun.star.beans.PropertyValue
Dim oUrl as new com.sun.star.util.URL
Dim oTrans as Object
Dim oDisp as Object
    oTrans = createUNOService("com.sun.star.util.URLTransformer")
    oUrl.Complete = "slot:" & CStr(SlotID)
    oTrans.parsestrict(oUrl)
    oDisp = StarDesktop.ActiveFrame.queryDispatch(oUrl, "_self", 0)
    oDisp.dispatch(oUrl, oArg())
End Sub


'returns the type of the office application
'FatOffice = 0, WebTop = 1
'This routine has to be changed if the Product Name is being changed!
Function IsFatOffice() As Boolean
  If sProductname = "" Then
    sProductname = GetProductname()
  End If
  IsFatOffice = TRUE
  'The following line has to include the current productname
  If Instr(1,sProductname,"WebTop",1) <> 0 Then
    IsFatOffice = FALSE
  End If
End Function


Function GetLocale(sLanguage as String, sCountry as String)
Dim oLocale as New com.sun.star.lang.Locale
    oLocale.Language = sLanguage
    oLocale.Country = sCountry
    GetLocale = oLocale
End Function


Sub ToggleDesignMode(oDocument as Object)
Dim aSwitchMode as new com.sun.star.util.URL
    aSwitchMode.Complete = ".uno:SwitchControlDesignMode"
    aTransformer = createUnoService("com.sun.star.util.URLTransformer")
    aTransformer.parseStrict(aSwitchMode)
    oFrame = oDocument.currentController.Frame
    oDispatch = oFrame.queryDispatch(aSwitchMode, oFrame.Name, 63)
        Dim aEmptyArgs() as New com.sun.star.bean.PropertyValue
    oDispatch.dispatch(aSwitchMode, aEmptyArgs())
    Erase aSwitchMode
End Sub


Function isHighContrast(oPeer as Object)
    Dim UIColor as Long
    Dim myRed as Integer
    Dim myGreen as Integer
    Dim myBlue as Integer
    Dim myLuminance as Double

    UIColor = oPeer.getProperty( "DisplayBackgroundColor" )
    myRed = Red (UIColor)
    myGreen = Green (UIColor)
    myBlue = Blue (UIColor)
    myLuminance = (( myBlue*28 + myGreen*151 + myRed*77 ) / 256    )
    isHighContrast = false
    If myLuminance <= 25 Then isHighContrast = true
End Function


Function CreateNewDocument(sType as String, Optional sAddMsg as String) as Object
Dim NoArgs() as new com.sun.star.beans.PropertyValue
Dim oDocument as Object
Dim sUrl as String
Dim ErrMsg as String
    On Local Error Goto NOMODULEINSTALLED
    sUrl = "private:factory/" & sType
    oDocument = StarDesktop.LoadComponentFromURL(sUrl,"_default",0, NoArgs())
NOMODULEINSTALLED:
    If (Err <> 0) OR IsNull(oDocument) Then
        If InitResources("", "com") Then
            Select Case sType
                Case "swriter"
                    ErrMsg = GetResText(1001)
                Case "scalc"
                    ErrMsg = GetResText(1002)
                Case "simpress"
                    ErrMsg = GetResText(1003)
                Case "sdraw"
                    ErrMsg = GetResText(1004)
                Case "smath"
                    ErrMsg = GetResText(1005)
                Case Else
                    ErrMsg = "Invalid Document Type!"
            End Select
            ErrMsg = ReplaceString(ErrMsg, chr(13), "<BR>")
            If Not IsMissing(sAddMsg) Then
                ErrMsg = ErrMsg & chr(13) & sAddMsg
            End If
            Msgbox(ErrMsg, 48, GetProductName())
        End If
        If Err <> 0 Then
            Resume GOON
        End If
    End If
GOON:
    CreateNewDocument = oDocument
End Function


' This Sub has been used in order to ensure that after disposing a document
' from the backing window it is returned to the backing window, so the
' office won't be closed
Sub DisposeDocument(oDocument as Object)
Dim dispatcher as Object
Dim parser as Object
Dim disp as Object
Dim url    as new com.sun.star.util.URL
Dim NoArgs() as New com.sun.star.beans.PropertyValue
Dim oFrame as Object
    If Not IsNull(oDocument) Then
        oDocument.setModified(false)
        parser   = createUnoService("com.sun.star.util.URLTransformer")
        url.Complete = ".uno:CloseDoc"
        parser.parseStrict(url)
        oFrame = oDocument.CurrentController.Frame
        disp = oFrame.queryDispatch(url,"_self", com.sun.star.util.SearchFlags.NORM_WORD_ONLY)
        disp.dispatch(url, NoArgs())
    End If
End Sub

'Function to calculate if the year is a leap year
Function CalIsLeapYear(ByVal iYear as Integer) as Boolean
        CalIsLeapYear = ((iYear Mod 4 = 0) And ((iYear Mod 100 <> 0) Or (iYear Mod 400 = 0)))
End Function
</script:module>